perm filename LET.45[MAC,LSP]1 blob
sn#493478 filedate 1980-01-26 generic text, type C, neo UTF8
COMMENT ā VALID 00009 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 LET -*-mode:lisppackage:si-*- -*-LISP-*-
C00004 00003
C00007 00004
C00011 00005
C00015 00006
C00019 00007
C00023 00008
C00024 00009 SAIL LET
C00030 ENDMK
Cā;
;;; LET -*-mode:lisp;package:si-*- -*-LISP-*-
;;; **************************************************************************
;;; ******** NIL ******** LET With Destructuring ****************************
;;; **************************************************************************
;;; ******** (C) Copyright 1980 Massachusetts Institute of Technology ********
;;; ************ THIS is a read-only file! (all writes reserved) *************
;;; **************************************************************************
;;; sail change
(declare (fasload defmac fas))
(EVAL-WHEN (eval compile)
(or (status macro /#)
(setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO))
(and (or (status feature MACLISP) (status feature LISPM))
(sstatus feature MQ))
)
#Q (globalize "LET" "LET*" "DESETQ")
#-LISPM
(herald LET /45)
#M (declare (own-symbol |LET.anyvarsp|))
(DECLARE (SPECIAL |LET.dcmp-newvars| |LET.dcmp-auxvars|)
(*EXPR |LET.decompose| |LET.step&decompose| |LET.make-list|
|LET.check-dcmpvars| |LET.anyvarsp| |LET*.iterate| )
(SETQ DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () )
(FIXNUM I LN))
(comment temporary macros)
;;; LEAVE these as defined by "macro" rather than "defmacro", so that
;;; one has a ghost of a chance of interpreting this file.
(macro NON-NULL-SYMBOL (x)
#+MQ `(AND ,(cadr x) (SYMBOLP ,(cadr x)))
#-MQ `(SYMBOLP ,(cadr x)))
(macro BIND (x)
((lambda (ll w vars vals)
(do ((l ll (cdr l)))
((null l))
(push (cond ((atom (car l)) (push () vals) (car l))
('T (push (cadar l) vals) (caar l)))
vars))
`((LAMBDA (,.(nreverse vars)) ,.w) ,.(nreverse vals)))
(cadr x) (cddr x) () () ))
(macro PUSHNRL (x)
((lambda (item lname) `(SETQ ,lname (NRECONC ,item ,lname)))
(cadr x) (caddr x)))
#-NIL
(progn 'compile
(macro TYPECASEQ (w)
(pop w)
`(#Q SELECTQ #M CASEQ (TYPEP ,(car w))
,.(mapcar '(lambda (x)
(cons (sublis '((PAIR . LIST)) (car x))
(cdr x)))
(cdr w))))
#M (defun |LET.make-list| (ln)
(do ((i ln (1- i)) (zz () (cons () zz)))
((zerop i) zz)))
#Q (macro |LET.make-list| (x) `(MAKE-LIST DEFAULT-CONS-AREA ,@(cdr x)))
)
#N (progn 'compile
(macro |LET.make-list| (x) `(MAKE-LIST ,(cadr x)))
;Following is for case of compiling LET to run under NILAID
#+MQ (macro TYPECASEQ (w)
(pop w)
`(#Q SELECTQ #M CASEQ (PTR-TYPEP ,(car w)) ,(cdr w)))
)
(DEFUN |LET.flattensyms| (ITEM L)
(COND ((ATOM ITEM)
(COND ((NULL ITEM) L)
((SYMBOLP ITEM) (COND ((MEMQ ITEM L) L) ((CONS ITEM L))))
(L)))
('T (|LET.flattensyms| (CAR ITEM) (|LET.flattensyms| (CDR ITEM) L)))))
(DEFUN |LET.check-dcmpvars| ()
(COND ((ATOM |LET.dcmp-newvars|) (ERROR '|LET.check-dcmpvars|))
((ATOM (CDR |LET.dcmp-newvars|))
(RPLACD |LET.dcmp-newvars| (LIST (GENSYM)))))
(CADR |LET.dcmp-newvars|))
(comment LET decomposer)
;;; Following function produces code to perform the decomposition
;;; indicated by the pattern.
(DEFUN |LET.decompose| (PAT VAR USEP)
(AND
PAT
(TYPECASEQ PAT
(SYMBOL `((SETQ ,pat ,var)))
(PAIR
(COND ((AND (ATOM (CAR PAT)) #N (NOT (VECTORP (CAR PAT))))
(|LET.decompose-1| 'CAR (CAR PAT) (CDR PAT) VAR USEP))
((AND (ATOM (CDR PAT)) #N (NOT (VECTORP (CDR PAT))))
(|LET.decompose-1| 'CDR (CDR PAT) (CAR PAT) VAR USEP))
((NOT (|LET.anyvarsp| (CAR PAT) () ))
(|LET.decompose-1| 'CAR () (CDR PAT) VAR USEP))
((NOT (|LET.anyvarsp| (CDR PAT) () ))
(|LET.decompose-1| 'CDR () (CAR PAT) VAR USEP))
('T (NCONC (|LET.step&decompose| 'CAR (CAR PAT) VAR () )
(|LET.step&decompose| 'CDR (CDR PAT) VAR USEP)))) )
#N ((VECTOR VECTOR-S)
(DO ((I 0 (1+ I))
(LN (VECTOR-LENGTH PAT))
(VDCMPL () ) (ITEM () ) (NEWVAR () ))
((NOT (< I LN)) (NREVERSE VDCMPL))
(AND (SETQ ITEM (VREF PAT I))
(TYPECASEQ ITEM
(SYMBOL (PUSH ITEM |LET.dcmp-auxvars|)
(PUSH `(SETQ ,item (VREF ,var ,i)) VDCMPL))
((PAIR VECTOR VECTOR-S)
(AND (|LET.anyvarsp| ITEM () )
(SETQ NEWVAR (|LET.check-dcmpvars|)
VDCMPL (NRECONC
((LAMBDA (|LET.dcmp-newvars|)
(|LET.decompose| ITEM NEWVAR 'T))
(CDR |LET.dcmp-newvars|))
`((SETQ ,newvar (VREF ,var ,i)) ,. vdcmpl)))))
(T () )))))
(T () ))))
;;; Only come here when PAT is either a PAIR or VECTOR, which furthermore
;;; has some variables in it (has passed |LET.anyvarsp| test).
;;; USEP null means we cant use the variable VAR for intermediate temps.
(DEFUN |LET.step&decompose| (CARCDR PAT VAR USEP)
(BIND ((NEWVAR VAR) (|LET.dcmp-newvars| |LET.dcmp-newvars|))
(COND ((NOT USEP)
(SETQ NEWVAR (|LET.check-dcmpvars|)
|LET.dcmp-newvars| (CDR |LET.dcmp-newvars|))))
`((SETQ ,newvar (,CARCDR ,var))
,. (|LET.decompose| pat newvar 't))))
;;; Come here with an atomic "APAT" (A-pattern), and do the decomposing.
(DEFUN |LET.decompose-1| (CARCDR APAT DPAT VAR USEP)
(PROG (D-DCMP CDRCAR A-NNSYM? D-VAR)
(SETQ A-NNSYM? (NON-NULL-SYMBOL APAT) D-VAR VAR)
(COND ((NOT (|LET.anyvarsp| DPAT () ))
(RETURN (COND ((AND A-NNSYM? (NOT (EQ APAT VAR)))
(PUSH APAT |LET.dcmp-auxvars|)
`((SETQ ,apat (,CARCDR ,var))))))))
;(AND A-NNSYM?
; (EQ APAT VAR)
; (SETQ D-VAR (some new var ########)))
(SETQ D-DCMP
(TYPECASEQ DPAT
(SYMBOL
(PUSH DPAT |LET.dcmp-auxvars|)
(SETQ CDRCAR (COND ((EQ CARCDR 'CAR) 'CDR) ('CAR)))
`((SETQ ,dpat (,CDRCAR ,d-var))) )
((PAIR #N VECTOR #N VECTOR-S)
(SETQ CDRCAR (COND ((EQ CARCDR 'CAR) 'CDR) ('CAR)))
(|LET.step&decompose| CDRCAR DPAT D-VAR USEP))
(T () )))
(COND (A-NNSYM?
(PUSH APAT |LET.dcmp-auxvars|)
(PUSH `(SETQ ,apat (,CARCDR ,var)) D-DCMP) ))
(RETURN D-DCMP)))
;;; If "RIGHTP" is non-null, searches the pattern "PAT" for the "rightmost"
;;; variable present in it; if null, then searches for "leftmost"
;;; Returns null if there aren't any variables in the pattern;
;;; otherwise, returns such variable
(DEFUN |LET.anyvarsp| (PAT RIGHTP)
(AND PAT
(TYPECASEQ PAT
(SYMBOL PAT)
#N ((VECTOR VECTOR-S)
(PROG (LN INCR IX TMP)
(DECLARE (FIXNUM LN INCR IX))
(SETQ LN (VECTOR-LENGTH PAT)
IX (COND (RIGHTP (SETQ INCR -1) (1- LN))
('T (SETQ INCR +1) 0)))
TG (AND (= 0 LN) (RETURN () ))
(AND (SETQ TMP (|LET.anyvarsp| (VREF PAT IX) RIGHTP))
(RETURN TMP))
(SETQ IX (+ INCR IX) LN (1- LN))
(GO TG)))
(PAIR (COND (RIGHTP (OR (|LET.anyvarsp| (CDR PAT) RIGHTP)
(|LET.anyvarsp| (CAR PAT) RIGHTP)))
('T (OR (|LET.anyvarsp| (CAR PAT) RIGHTP)
(|LET.anyvarsp| (CDR PAT) RIGHTP)))))
(T () ))))
(comment DESETQ Expander)
(DEFUN DESETQ-expander-1 (LL)
(PROG (L DCMPL GVAR GVAR-INIT ITEM PAT TMP
|LET.dcmp-auxvars| |LET.dcmp-newvars|)
(SETQ L LL |LET.dcmp-newvars| (LIST () ))
LOOP-START
(AND (ATOM L) (GO EXIT))
(SETQ PAT (CAR L) ITEM (CADR L))
(COND ((NULL ITEM)
(OR (SETQ TMP (|LET.flattensyms| PAT () )) (GO BAD))
(MAPC '(LAMBDA (X) (PUSH `(SETQ ,x () ) DCMPL)) TMP)
(GO LOOP-CYCLE)))
(COND ((ATOM PAT)
(OR PAT (GO BAD))
(TYPECASEQ PAT
(SYMBOL
(PUSH `(SETQ ,pat ,item) DCMPL)
(GO LOOP-CYCLE))
#N ((VECTORP PAT)
(TYPECASEQ ITEM
((PAIR SYMBOL VECTOR VECTOR-S EXTEND) () )
(T (GO BAD))))
('T (GO BAD)) ))
((TYPECASEQ ITEM
(SYMBOL
(COND ((NOT (EQ ITEM (CAR PAT)))
;like (desetq (a b) c), not like (desetq (a b) a)
(PUSHNRL (|LET.decompose| PAT ITEM ()) DCMPL)
(GO LOOP-CYCLE))))
(PAIR () )
(T (GO BAD)) )))
;Instead of setting up GVAR to be a gensym, we could take the
; "rightmost" variable in a pattern like "(<atom> . mumble)", or
; "leftmost" variable in a pattern like "(mumble . <atom>)",
; providing such variable can be found which is not declared to
; be numeric. This is main difference for LISPM, which doesn't
; want these extra vars generated at all. ##########
(AND (NULL GVAR) (SETQ GVAR (GENSYM)))
;Normal destructuring a random item, e.g. (desetq (f g h) (mumble 3))
(PUSH `(SETQ ,gvar ,item) DCMPL)
(PUSHNRL (|LET.decompose| PAT GVAR 'T) DCMPL)
LOOP-CYCLE
(SETQ L (CDDR L))
(GO LOOP-START)
EXIT
(SETQ DCMPL (NREVERSE DCMPL))
(RETURN
(COND ((AND (NULL GVAR) (NULL (CDR |LET.dcmp-newvars|)))
`(PROGN ,. dcmpl))
('T (COND ((NULL GVAR))
('T (COND ((AND (EQ (CAAR DCMPL) 'SETQ)
(EQ (CADAR DCMPL) GVAR)
(NULL (CDDDAR DCMPL)))
(SETQ GVAR-INIT (CADDAR DCMPL))
(POP DCMPL)))
(SETQ GVAR `(,gvar)
GVAR-INIT `(,gvar-init))))
(POP |LET.dcmp-newvars|)
(SETQ ITEM (length |LET.dcmp-newvars|))
`((LAMBDA (,. gvar ,. |LET.dcmp-newvars|)
,. dcmpl)
,. gvar-init ,. (|LET.make-list| item) ))))
BAD (ERROR '|Bad form to DESETQ| `(DESETQ ,pat ,item))
))
(comment LET* Expander)
(DEFUN LET*-expander-1 (L)
(COND ((ATOM (CAR L)) (LET-expander-1 L))
((BIND ((LETL (CAR L)) (LMBODY (CDR L)) DECLP)
(COND ((AND (NOT (ATOM (CAR LMBODY)))
(EQ (CAAR LMBODY) 'DECLARE))
(SETQ DECLP (LIST (CAR LMBODY)))
(SETQ LMBODY (CDR LMBODY))))
`(LET (,(car letl))
,@declp
,(|LET*.iterate| (cdr letl) lmbody))))))
(DEFUN |LET*.iterate| (LETL LMBODY)
(COND ((NULL LETL) `(PROGN ,. lmbody))
(`(LET (,(car letl)) ,(|LET*.iterate| (cdr letl) lmbody)))))
(comment LET Expander)
(DEFUN LET-expander-1 (L)
(PROG (LETL LMBODY |LET.dcmp-newvars| |LET.dcmp-auxvars| VARS VALS
GVAR DECLP DCMPL LL OK-FL)
(SETQ LETL (CAR L)
LMBODY (CDR L)
|LET.dcmp-newvars| (LIST () )
OK-FL 'T)
(COND ((AND (NOT (ATOM (CAR LMBODY)))
(EQ (CAAR LMBODY) 'DECLARE))
(SETQ DECLP (LIST (CAR LMBODY)))
(SETQ LMBODY (CDR LMBODY))))
(mapc '(lambda (il)
(cond ((atom il)
(cond ((non-null-symbol il)
(push il vars) (push () vals))
('t (setq ok-fl () ))))
((cddr il) (setq ok-fl () ))
((or (null (car il)) (symbolp (car il)))
(push (car il) vars) (push (cadr il) vals))
((or (not (atom (car il))) #N (vectorp (car il)) )
(cond ((or (null (cdr il)) (null (cadr il)))
(setq |LET.dcmp-auxvars|
(|LET.flattensyms|
(car il)
|LET.dcmp-auxvars|)))
('t (push (cadr il) vals)
(setq gvar (gensym))
(setq ll (|LET.decompose| (car il) gvar 'T))
(push (cond ((null ll) () ) (gvar)) vars)
(setq dcmpl (nconc ll dcmpl)))))
('t (setq ok-fl () ))))
letl)
(AND (NOT OK-FL) (ERROR '|Bad variable list in LET| L))
(COND ((SETQ |LET.dcmp-auxvars| (NCONC (CDR |LET.dcmp-newvars|)
|LET.dcmp-auxvars|))
(SETQ VARS (NRECONC VARS |LET.dcmp-auxvars|)
VALS (NRECONC VALS (|LET.make-list| (LENGTH |LET.dcmp-auxvars|)))))
('T (SETQ VARS (NREVERSE VARS) VALS (NREVERSE VALS))))
(RETURN `((LAMBDA ,vars
,@declp
,.(nconc dcmpl lmbody))
,.vals))))
(comment Macro definitions)
#+MQ (progn 'compile
(declare (SETQ DEFMACRO-DISPLACE-CALL 'T
DEFMACRO-FOR-COMPILING 'T
DEFMACRO-CHECK-ARGS () ))
(DEFMACRO-DISPLACE DESETQ (&REST L) (DESETQ-expander-1 L))
(DEFMACRO-DISPLACE LET* (&REST L) (LET*-expander-1 L))
;;; WAIT! You loser, don't move this macro definition. It must occur
;;; at the end, so that the previous LET will be active during
;;; compilation.
(DEFMACRO-DISPLACE LET! (&REST L) (LET-expander-1 L))
)
;;; SAIL LET
;;; Does lambda binding
(declare (*fexpr code)(*expr %match macrobind %%destructurify%% %%expand%%
sail-letp)
(special %%clobber-macros%%))
(declare (special *bindings *form *vars *vals *a *b *vars1 *vars2 *vals1 *vals2))
(defprop %match ((dsk (mac lsp)) match fas) autoload)
(defprop code ((dsk (mac lsp)) macrod fas) autoload)
(defun do-execute-memq (x)
(memq x '(do execute)))
(defun (let macro) (x)
(cond ((not (memq '/ā (cdr x)))
`(let! . ,(cdr x)))
(t
((lambda (q)
(cond ((and
*rset
(cond ((boundp '%%clobber-macros%%)
(not %%clobber-macros%%))
(t)))
q)
((atom q)
q)
(t (rplaca x (car q))
(rplacd x (cdr q)))))
((lambda (*bindings *form)
(cond ((%match '(*bindings then *form) (cdr x))
(setq *form (ncons (cons 'let *form))))
(t (%match '(*bindings
($r ? do-execute-memq)
*form) (cdr x))))
((lambda (*vars *vals)
(do ((*a nil *a)
(*b nil *b))
((null (%match '(*a ā *b)
*bindings))
((lambda (*vars1 *vals1 *vars2 *vals2)
(mapc
(function
(lambda
(q)
(and (car q)
(setq *vars1 (cons (car q) *vars1)
*vals1 (cons (cadr q) *vals1)))
(mapc
(function
(lambda (r)
(setq *vars2 (cons (car r) *vars2)
*vals2 (cons (cadr r) *vals2))))
(caddr q))))
(%%destructurify%% *vars *vals))
(setq *vars1 (nreverse *vars1)
*vars2 (nreverse *vars2)
*vals1 (nreverse *vals1)
*vals2 (nreverse *vals2))
(cond ((null *vars1)
(cond ((null *vars2)
(code (progn *form)))
(t
(code
((lambda (*vars2)
*form)
*vals2)))))
(t
(cond ((null *vars2)
(code
((lambda (*vars1)
*form)
*vals1)))
(t
(code ((lambda (*vars1)
((lambda (*vars2)
*form)
*vals2))
*vals1)))))))
nil nil nil nil))
(do ((n (1- (length *a))
(1- n))
(x (ncons (car *b))
(cons (car *b) x)))
((zerop n) (setq *bindings (cdr *b)
*b (nreverse x)))
(setq *b (cdr *b)))
(setq *vars (append
*vars *a)
*vals (append
*vals *b))))
nil nil)) nil nil))) ))
;(defun destructure (l)
; (destructure1 l nil))
(defun %%destructure1%% (l path)
(cond ((null l) nil)
((atom l)(ncons (cons l path)))
(t (append (%%destructure1%% (car l) (cons 'car path))
(%%destructure1%% (cdr l) (cons 'cdr path))))))
(defun %%destructurify%% (vars vals)
(mapcar
(function
(lambda (q r)
(cond ((atom q)
(list q r nil))
((atom r)
(list nil nil (%%pathify%% (%%destructure1%% q nil) r)))
(t ((lambda (g)
(list g r (%%pathify%% (%%destructure1%% q nil) g)))
(gensym))))))
vars vals))
(defun %%pathify%% (path gen)
(mapcar
(function
(lambda (q)
(list (car q) (%%code-path%% (cdr q) gen))))
path))
(defun %%code-path%% (path name)
(cond ((null path) name)
(t (list (car path) (%%code-path%% (cdr path) name)))))